home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xlcont.c < prev    next >
Text File  |  1985-12-25  |  19KB  |  878 lines
  1. /* xlcont - xlisp control built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE ***xlstack,*xlenv,*xlvalue;
  10. extern NODE *s_unbound;
  11. extern NODE *s_evalhook,*s_applyhook;
  12. extern NODE *true;
  13.  
  14. /* external routines */
  15. extern NODE *xlxeval();
  16.  
  17. /* forward declarations */
  18. FORWARD NODE *let();
  19. FORWARD NODE *prog();
  20. FORWARD NODE *progx();
  21. FORWARD NODE *doloop();
  22.  
  23. /* xcond - built-in function 'cond' */
  24. NODE *xcond(args)
  25.   NODE *args;
  26. {
  27.     NODE ***oldstk,*arg,*list,*val;
  28.  
  29.     /* create a new stack frame */
  30.     oldstk = xlsave(&arg,&list,NULL);
  31.  
  32.     /* initialize */
  33.     arg = args;
  34.  
  35.     /* initialize the return value */
  36.     val = NIL;
  37.  
  38.     /* find a predicate that is true */
  39.     while (arg) {
  40.  
  41.     /* get the next conditional */
  42.     list = xlmatch(LIST,&arg);
  43.  
  44.     /* evaluate the predicate part */
  45.     if (val = xlevarg(&list)) {
  46.  
  47.         /* evaluate each expression */
  48.         while (list)
  49.         val = xlevarg(&list);
  50.  
  51.         /* exit the loop */
  52.         break;
  53.     }
  54.     }
  55.  
  56.     /* restore the previous stack frame */
  57.     xlstack = oldstk;
  58.  
  59.     /* return the value */
  60.     return (val);
  61. }
  62.  
  63. /* xcase - built-in function 'case' */
  64. NODE *xcase(args)
  65.   NODE *args;
  66. {
  67.     NODE ***oldstk,*key,*arg,*clause,*list,*val;
  68.  
  69.     /* create a new stack frame */
  70.     oldstk = xlsave(&key,&arg,&clause,NULL);
  71.  
  72.     /* initialize */
  73.     arg = args;
  74.  
  75.     /* get the key expression */
  76.     key = xlevarg(&arg);
  77.  
  78.     /* initialize the return value */
  79.     val = NIL;
  80.  
  81.     /* find a case that matches */
  82.     while (arg) {
  83.  
  84.     /* get the next case clause */
  85.     clause = xlmatch(LIST,&arg);
  86.  
  87.     /* compare the key list against the key */
  88.     if ((list = xlarg(&clause)) == true ||
  89.             (listp(list) && keypresent(key,list)) ||
  90.             eql(key,list)) {
  91.  
  92.         /* evaluate each expression */
  93.         while (clause)
  94.         val = xlevarg(&clause);
  95.  
  96.         /* exit the loop */
  97.         break;
  98.     }
  99.     }
  100.  
  101.     /* restore the previous stack frame */
  102.     xlstack = oldstk;
  103.  
  104.     /* return the value */
  105.     return (val);
  106. }
  107.  
  108. /* keypresent - check for the presence of a key in a list */
  109. LOCAL int keypresent(key,list)
  110.   NODE *key,*list;
  111. {
  112.     for (; consp(list); list = cdr(list))
  113.     if (eql(car(list),key))
  114.         return (TRUE);
  115.     return (FALSE);
  116. }
  117.  
  118. /* xand - built-in function 'and' */
  119. NODE *xand(args)
  120.   NODE *args;
  121. {
  122.     NODE ***oldstk,*arg,*val;
  123.  
  124.     /* create a new stack frame */
  125.     oldstk = xlsave(&arg,NULL);
  126.  
  127.     /* initialize */
  128.     arg = args;
  129.     val = true;
  130.  
  131.     /* evaluate each argument */
  132.     while (arg)
  133.  
  134.     /* get the next argument */
  135.     if ((val = xlevarg(&arg)) == NIL)
  136.         break;
  137.  
  138.     /* restore the previous stack frame */
  139.     xlstack = oldstk;
  140.  
  141.     /* return the result value */
  142.     return (val);
  143. }
  144.  
  145. /* xor - built-in function 'or' */
  146. NODE *xor(args)
  147.   NODE *args;
  148. {
  149.     NODE ***oldstk,*arg,*val;
  150.  
  151.     /* create a new stack frame */
  152.     oldstk = xlsave(&arg,NULL);
  153.  
  154.     /* initialize */
  155.     arg = args;
  156.     val = NIL;
  157.  
  158.     /* evaluate each argument */
  159.     while (arg)
  160.     if ((val = xlevarg(&arg)))
  161.         break;
  162.  
  163.     /* restore the previous stack frame */
  164.     xlstack = oldstk;
  165.  
  166.     /* return the result value */
  167.     return (val);
  168. }
  169.  
  170. /* xif - built-in function 'if' */
  171. NODE *xif(args)
  172.   NODE *args;
  173. {
  174.     NODE ***oldstk,*testexpr,*thenexpr,*elseexpr,*val;
  175.  
  176.     /* create a new stack frame */
  177.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  178.  
  179.     /* get the test expression, then clause and else clause */
  180.     testexpr = xlarg(&args);
  181.     thenexpr = xlarg(&args);
  182.     elseexpr = (args ? xlarg(&args) : NIL);
  183.     xllastarg(args);
  184.  
  185.     /* evaluate the appropriate clause */
  186.     val = xleval(xleval(testexpr) ? thenexpr : elseexpr);
  187.  
  188.     /* restore the previous stack frame */
  189.     xlstack = oldstk;
  190.  
  191.     /* return the last value */
  192.     return (val);
  193. }
  194.  
  195. /* xlet - built-in function 'let' */
  196. NODE *xlet(args)
  197.   NODE *args;
  198. {
  199.     return (let(args,TRUE));
  200. }
  201.  
  202. /* xletstar - built-in function 'let*' */
  203. NODE *xletstar(args)
  204.   NODE *args;
  205. {
  206.     return (let(args,FALSE));
  207. }
  208.  
  209. /* let - common let routine */
  210. LOCAL NODE *let(args,pflag)
  211.   NODE *args; int pflag;
  212. {
  213.     NODE ***oldstk,*newenv,*arg,*val;
  214.  
  215.     /* create a new stack frame */
  216.     oldstk = xlsave(&newenv,&arg,NULL);
  217.  
  218.     /* initialize */
  219.     arg = args;
  220.  
  221.     /* create a new environment frame */
  222.     newenv = xlframe(xlenv);
  223.  
  224.     /* get the list of bindings and bind the symbols */
  225.     if (!pflag) xlenv = newenv;
  226.     dobindings(xlmatch(LIST,&arg),newenv);
  227.     if (pflag) xlenv = newenv;
  228.  
  229.     /* execute the code */
  230.     for (val = NIL; arg; )
  231.     val = xlevarg(&arg);
  232.  
  233.     /* unbind the arguments */
  234.     xlenv = cdr(xlenv);
  235.  
  236.     /* restore the previous stack frame */
  237.     xlstack = oldstk;
  238.  
  239.     /* return the result */
  240.     return (val);
  241. }
  242.  
  243. /* xprog - built-in function 'prog' */
  244. NODE *xprog(args)
  245.   NODE *args;
  246. {
  247.     return (prog(args,TRUE));
  248. }
  249.  
  250. /* xprogstar - built-in function 'prog*' */
  251. NODE *xprogstar(args)
  252.   NODE *args;
  253. {
  254.     return (prog(args,FALSE));
  255. }
  256.  
  257. /* prog - common prog routine */
  258. LOCAL NODE *prog(args,pflag)
  259.   NODE *args; int pflag;
  260. {
  261.     NODE ***oldstk,*newenv,*arg,*val;
  262.  
  263.     /* create a new stack frame */
  264.     oldstk = xlsave(&newenv,&arg,NULL);
  265.  
  266.     /* initialize */
  267.     arg = args;
  268.  
  269.     /* create a new environment frame */
  270.     newenv = xlframe(xlenv);
  271.  
  272.     /* get the list of bindings and bind the symbols */
  273.     if (!pflag) xlenv = newenv;
  274.     dobindings(xlmatch(LIST,&arg),newenv);
  275.     if (pflag) xlenv = newenv;
  276.  
  277.     /* execute the code */
  278.     tagblock(arg,&val);
  279.  
  280.     /* unbind the arguments */
  281.     xlenv = cdr(xlenv);
  282.  
  283.     /* restore the previous stack frame */
  284.     xlstack = oldstk;
  285.  
  286.     /* return the result */
  287.     return (val);
  288. }
  289.  
  290. /* xgo - built-in function 'go' */
  291. NODE *xgo(args)
  292.   NODE *args;
  293. {
  294.     NODE *label;
  295.  
  296.     /* get the target label */
  297.     label = xlarg(&args);
  298.     xllastarg(args);
  299.  
  300.     /* transfer to the label */
  301.     xlgo(label);
  302. }
  303.  
  304. /* xreturn - built-in function 'return' */
  305. NODE *xreturn(args)
  306.   NODE *args;
  307. {
  308.     NODE *val;
  309.  
  310.     /* get the return value */
  311.     val = (args ? xlarg(&args) : NIL);
  312.     xllastarg(args);
  313.  
  314.     /* return from the inner most block */
  315.     xlreturn(val);
  316. }
  317.  
  318. /* xprog1 - built-in function 'prog1' */
  319. NODE *xprog1(args)
  320.   NODE *args;
  321. {
  322.     return (progx(args,1));
  323. }
  324.  
  325. /* xprog2 - built-in function 'prog2' */
  326. NODE *xprog2(args)
  327.   NODE *args;
  328. {
  329.     return (progx(args,2));
  330. }
  331.  
  332. /* progx - common progx code */
  333. LOCAL NODE *progx(args,n)
  334.   NODE *args; int n;
  335. {
  336.     NODE ***oldstk,*arg,*val;
  337.  
  338.     /* create a new stack frame */
  339.     oldstk = xlsave(&arg,&val,NULL);
  340.  
  341.     /* initialize */
  342.     arg = args;
  343.  
  344.     /* evaluate the first n expressions */
  345.     while (n--)
  346.     val = xlevarg(&arg);
  347.  
  348.     /* evaluate each remaining argument */
  349.     while (arg)
  350.     xlevarg(&arg);
  351.  
  352.     /* restore the previous stack frame */
  353.     xlstack = oldstk;
  354.  
  355.     /* return the last test expression value */
  356.     return (val);
  357. }
  358.  
  359. /* xprogn - built-in function 'progn' */
  360. NODE *xprogn(args)
  361.   NODE *args;
  362. {
  363.     NODE ***oldstk,*arg,*val;
  364.  
  365.     /* create a new stack frame */
  366.     oldstk = xlsave(&arg,NULL);
  367.  
  368.     /* initialize */
  369.     arg = args;
  370.  
  371.     /* evaluate each remaining argument */
  372.     for (val = NIL; arg; )
  373.     val = xlevarg(&arg);
  374.  
  375.     /* restore the previous stack frame */
  376.     xlstack = oldstk;
  377.  
  378.     /* return the last test expression value */
  379.     return (val);
  380. }
  381.  
  382. /* xdo - built-in function 'do' */
  383. NODE *xdo(args)
  384.   NODE *args;
  385. {
  386.     return (doloop(args,TRUE));
  387. }
  388.  
  389. /* xdostar - built-in function 'do*' */
  390. NODE *xdostar(args)
  391.   NODE *args;
  392. {
  393.     return (doloop(args,FALSE));
  394. }
  395.  
  396. /* doloop - common do routine */
  397. LOCAL NODE *doloop(args,pflag)
  398.   NODE *args; int pflag;
  399. {
  400.     NODE ***oldstk,*newenv,*arg,*blist,*clist,*test,*rval;
  401.     int rbreak;
  402.  
  403.     /* create a new stack frame */
  404.     oldstk = xlsave(&newenv,&arg,&bl